home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / thing.el.z / thing.el
Encoding:
Text File  |  1998-05-21  |  11.8 KB  |  334 lines
  1. ;;; thing.el --- find language-specific contiguous pieces of text
  2.  
  3. ;; Keywords: extensions, languages
  4.  
  5. ;;; Authors: David Hughes <djh@cis.prime.com>
  6. ;;;              adapted from Martin Boyer's thing.el for imouse
  7. ;;;          Martin Boyer, IREQ <mboyer@ireq-robot.hydro.qc.ca>
  8. ;;;              adapted from Heinz Schmidt's thing.el for sky-mouse
  9. ;;;          Heinz Schmidt, ICSI (hws@ICSI.Berkeley.EDU)
  10. ;;;              adapted from Dan L. Pierson's epoch-thing.el
  11. ;;;          Dan L. Pierson <pierson@encore.com>, 2/5/90
  12. ;;;              adapted from Joshua Guttman's Thing.el
  13. ;;;          Joshua Guttman, MITRE (guttman@mitre.org)
  14. ;;;              adapted from sun-fns.el by Joshua Guttman, MITRE.
  15. ;;;
  16. ;;; Copyright (C) International Computer Science Institute, 1991
  17. ;;;
  18.  
  19. ;; This file is part of XEmacs.
  20.  
  21. ;; XEmacs is free software; you can redistribute it and/or modify
  22. ;; it under the terms of the GNU General Public License as published by
  23. ;; the Free Software Foundation; either version 2, or (at your option)
  24. ;; any later version.
  25.  
  26. ;; XEmacs is distributed in the hope that it will be useful,
  27. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  28. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  29. ;; GNU General Public License for more details.
  30.  
  31. ;; You should have received a copy of the GNU General Public License
  32. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  33. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  34. ;; 02111-1307, USA.
  35.  
  36. ;;; Synched up with: Not in FSF.
  37. ;;; #### FSF has thingatpt.el, which does the same thing.  Should merge
  38. ;;; or toss this.
  39.  
  40. ;;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  41. ;;;* FUNCTION: Things are language objects contiguous pieces of text
  42. ;;;*           whose boundaries can be defined by syntax or context.
  43. ;;;*
  44. ;;;* RELATED PACKAGES: various packages built on this.
  45. ;;;*
  46. ;;;* HISTORY:
  47. ;;;* Last edited: David Hughes 21st December 1992
  48. ;;;*  jul 21 21:00 1993 (tlp00): added a kludgy thing-filename
  49. ;;;*  Feb 22 21:00 1993 (tlp00): better merge with lucid and imouse
  50. ;;;*  Dec 21 11:11 1992 (djh): added thing-report-char-p
  51. ;;;*  Nov 23 18:00 1992 (djh): merged in Guido Bosch's ideas
  52. ;;;*  Sep 10 15:35 1992 (djh): adapted for Lucid emacs19-mouse.el
  53. ;;;*  Nov 28 17:40 1991 (mb): Cleaned up, and added thing-bigger-alist.
  54. ;;;*  May 24 00:33 1991 (hws): overworked and added syntax.
  55. ;;;* Created: 2/5/90 Dan L. Pierson
  56. ;;;*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  57.  
  58. (provide 'thing)
  59.  
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61. ;;;;;;;;;;;;  Customization and Entry Point  ;;;;;;;;;;;;;;;;;;;;;;;;;
  62. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63.  
  64. (defvar thing-boundary-alist
  65.   '((?w thing-word)
  66.     (?_ thing-symbol)
  67.     (?\( thing-sexp-start)
  68.     (?\$ thing-sexp-start)
  69.     (?' thing-sexp-start)
  70.     (?\" thing-sexp-start)
  71.     (?\) thing-sexp-end)
  72.     (?  thing-whitespace)
  73.     (?< thing-comment)
  74.     (?. thing-next-sexp))
  75.   "*List of pairs of the form (SYNTAX-CHAR FUNCTION) used by
  76. the function `thing-boundaries'.")
  77.  
  78. (defvar thing-report-char-p t
  79.   "*Non nil means return single char boundaries if all else fails")
  80.  
  81. (defvar thing-report-whitespace t
  82.   "*Non nil means that whitespaces are considered as things, otherwise not.")
  83.  
  84. (defvar *last-thing*
  85.   "The last thing found by thing-boundaries.  Used for chaining commands.")
  86.  
  87. ;; The variable and function `thing-region' are to avoid the continual
  88. ;; construction of cons cells as result af the thing scanner functions.
  89. ;; This avoids unnecessary garbage collection. Guido Bosch <bosch@loria.fr>
  90.  
  91. (defvar thing-region (cons 'nil 'nil)
  92.   "Cons cell that contains a region (<beginning> . <end>)
  93. The function `thing-region' updates and returns it.")
  94.  
  95. (defun thing-region (beginning end)
  96.   "Make BEGINNING the car and END the cdr of the cons cell in the
  97. variable `thing-region'. Return the updated cons cell"
  98.   (cond ((/= beginning end)
  99.          (setcar thing-region beginning)
  100.          (setcdr thing-region end)
  101.          thing-region)))
  102.  
  103. (defvar thing-bigger-alist
  104.   '((word-symbol thing-symbol)
  105.     (symbol thing-sexp)
  106.     (word-sexp thing-sexp)
  107.     (sexp thing-up-sexp)
  108.     (sexp-up thing-up-sexp)
  109.     (line thing-paragraph)
  110.     (paragraph thing-page)
  111.     (char thing-word)
  112.     (word-sentence thing-sentence)
  113.     (sentence thing-paragraph))
  114.   "List of pairs to go from one thing to a bigger thing.
  115. See mouse-select-bigger-thing and mouse-delete-bigger-thing.")
  116.  
  117. (defvar thing-word-next nil
  118.   "*The next bigger thing after a word.  A symbol.
  119. Supported values are: word-symbol, word-sexp, and word-sentence.
  120. Default value is word-sentence.
  121. Automatically becomes local when set in any fashion.")
  122. (make-variable-buffer-local 'thing-word-next)
  123.  
  124. (defun thing-boundaries (here)
  125.   "Return start and end of text object at HERE using syntax table and
  126. thing-boundary-alist.  Thing-boundary-alist is a list of pairs of the
  127. form (SYNTAX-CHAR FUNCTION) where FUNCTION takes a single position
  128. argument and returns a cons of places (start end) representing
  129. boundaries of the thing at that position.
  130.  
  131. Typically:
  132.  Left or right Paren syntax indicates an s-expression.
  133.  The end of a line marks the line including a trailing newline.
  134.  Word syntax indicates current word.
  135.  Symbol syntax indicates symbol.
  136.  If it doesn't recognize one of these it selects just the character HERE.
  137.  
  138. If an error occurs  during syntax scanning, the function just prints a
  139. message and returns `nil'."
  140.   (interactive "d")
  141.   (setq *last-thing* nil)
  142.   (if (save-excursion (goto-char here) (eolp))
  143.       (thing-get-line here)
  144.     (let* ((syntax (char-syntax (char-after here)))
  145.            (pair (assq syntax thing-boundary-alist)))
  146.       (cond ((and pair
  147.           (or thing-report-whitespace
  148.               (not (eq (car (cdr pair)) 'thing-whitespace))))
  149.              (funcall (car (cdr pair)) here))
  150.             (thing-report-char-p
  151.              (setq *last-thing* 'char)
  152.              (thing-region here (1+ here)))
  153.             (t
  154.              nil)))))
  155.  
  156.  
  157.  
  158.  
  159. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  160. ;;;;;;;;;;;;;;;;;  Code Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  161. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  162.  
  163. (defun thing-symbol (here)
  164.   "Return start and end of symbol at HERE."
  165.   (cond ((memq (char-syntax (char-after here)) '(?_ ?w))
  166.          (setq *last-thing* 'symbol)
  167.          (let ((end (scan-sexps here 1)))
  168.            (if end
  169.            (thing-region (min here (scan-sexps end -1)) end))))))
  170.  
  171. (defun thing-filename (here)
  172.   "Return start and end of filename at HERE."
  173.   (cond ((and (memq (char-syntax (char-after here)) '(?w ?_ ?.))
  174.           (< here (point-max)))
  175.          (let (start end)
  176.        (save-excursion
  177.          (goto-char here)
  178.          (and (re-search-forward "\\s \\|:\\s\"\\|$" nil t)
  179.           (goto-char (setq end (match-beginning 0)))
  180.           (or
  181.            (and 
  182.             (re-search-backward "[^_a-zA-Z0-9---#$.~/@]+" nil t)
  183.             (setq start (+ (match-beginning 0)
  184.                    (if (bolp)
  185.                        0
  186.                      1))))
  187.            (setq start (point-min)))
  188.           (thing-region (min start here) (max here end))))))))
  189. ;~/  
  190. (defun thing-sexp-start (here)
  191.   "Return start and end of sexp starting HERE."
  192.   (setq *last-thing* 'sexp-start)
  193.   (thing-region here (scan-sexps here 1)))
  194.  
  195. (defun thing-sexp-end (here)
  196.   "Return start and end of sexp ending HERE."
  197.   (setq *last-thing* 'sexp-end)
  198.   (thing-region (scan-sexps (1+ here) -1) (1+ here)))
  199.  
  200. (defun thing-sexp (here)
  201.   "Return start and end of the sexp at HERE."
  202.   (setq *last-thing* 'sexp)
  203.   (save-excursion
  204.     (goto-char here)
  205.     (thing-region (progn (backward-up-list 1) (point))
  206.                   (progn (forward-list 1) (point)))))
  207.  
  208. (defun thing-up-sexp (here)
  209.   "Return start and end of the sexp enclosing the selected area."
  210.   (setq *last-thing* 'sexp-up)
  211.   ;; Keep going up and backward in sexps.  This means that thing-up-sexp
  212.   ;; can only be called after thing-sexp or after itself.
  213.   (save-excursion
  214.     (goto-char here)
  215.     (thing-region (progn 
  216.             (condition-case ()
  217.             (backward-up-list 1) (error nil))
  218.             (point))
  219.                   (progn 
  220.             (condition-case () 
  221.             (forward-list 1) (error nil))
  222.             (point)))))
  223.  
  224. ;;; Allow punctuation marks not followed by white-space to include
  225. ;;; the subsequent sexp. Useful in foo.bar(x).baz and such.
  226. (defun thing-next-sexp (here)
  227.   "Return from HERE to the end of the sexp at HERE,
  228. if the character at HERE is part of a sexp."
  229.   (setq *last-thing* 'sexp-next)
  230.   (if (= (char-syntax (char-after (1+ here))) ? )
  231.       (thing-region here (1+ here))
  232.     (thing-region here
  233.                   (save-excursion (goto-char here) (forward-sexp) (point)))))
  234.  
  235. ;;; Allow click to comment-char to extend to end of line
  236. (defun thing-comment (here)
  237.   "Return rest of line from HERE to newline."
  238.   (setq *last-thing* 'comment)
  239.   (save-excursion (goto-char here)
  240.                   (while (= (char-syntax (preceding-char)) ?<)
  241.                     (forward-char -1))
  242.                   (thing-region (point) (progn (end-of-line) (point)))))
  243.  
  244.  
  245. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  246. ;;;;;;;;;;;;;;;;;  Text Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  247. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  248.  
  249. (defun thing-word (here)
  250.   "Return start and end of word at HERE."
  251.   (setq *last-thing* 
  252.     (if thing-word-next
  253.         thing-word-next
  254.       (setq thing-word-next
  255.         (cond 
  256.          ((memq major-mode '(emacs-lisp-mode c-mode c++-mode
  257.                          fortran-mode latex-mode lisp-mode
  258.                      perl-mode tex-mode))
  259.           'word-symbol)
  260.          (t 'word-sentence)))))
  261.   (save-excursion
  262.     (goto-char here)
  263.     (forward-word 1)
  264.     (let ((end (point)))
  265.       (forward-word -1)
  266.       (thing-region (point) end))))
  267.  
  268. (defun thing-sentence (here)
  269.   "Return start and end of the sentence at HERE."
  270.   (setq *last-thing* 'sentence)
  271.   (save-excursion
  272.     (goto-char here)
  273.     (thing-region (progn (backward-sentence) (point))
  274.                   (progn (forward-sentence) (point)))))
  275.  
  276. (defun thing-whitespace (here)
  277.   "Return start to end of all of whitespace HERE."
  278.   (setq *last-thing* 'whitespace)
  279.   (save-excursion
  280.     (goto-char here)
  281.     (let ((start (progn (skip-chars-backward " \t") (1+ (point))))
  282.           (end (progn (skip-chars-forward " \t") (point))))
  283.       (if (= start end)
  284.           (thing-region (1- start) end)
  285.         (thing-region start end)))))
  286.  
  287.  
  288. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  289. ;;;;;;;;;;;;;;;  Physical Delimiters  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  290. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  291.  
  292. (defun thing-get-line (here)
  293.   "Return whole of line HERE is in, with newline unless at eob."
  294.   (setq *last-thing* 'line)
  295.   (save-excursion
  296.     (goto-char here)
  297.     (let* ((start (progn (beginning-of-line 1) (point))))
  298.       (thing-region start (point)))))
  299.  
  300. (defun thing-paragraph (here)
  301.   "Return start and end of the paragraph at HERE."
  302.   (setq *last-thing* 'paragraph)
  303.   (save-excursion
  304.     (goto-char here)
  305.     (thing-region (progn (backward-paragraph) (point))
  306.                   (progn (forward-paragraph) (point)))))
  307.  
  308. (defun thing-page (here)
  309.   "Return start and end of the page at HERE."
  310.   (setq *last-thing* 'page)
  311.   (save-excursion
  312.     (goto-char here)
  313.     (thing-region (progn (backward-page) (point))
  314.                   (progn (forward-page) (point)))))
  315.  
  316.  
  317. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  318. ;;;;;;;;;;;;;;;;  Support functions  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  319. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  320.  
  321. (defun kill-thing-at-point (here)
  322.   "Kill text object using syntax table.
  323. See thing-boundaries for definition of text objects"
  324.   (interactive "d")
  325.   (let ((bounds (thing-boundaries here)))
  326.     (kill-region (car bounds) (cdr bounds))))
  327.  
  328. (defun copy-thing-at-point (here)
  329.   "Copy text object using syntax table.
  330. See thing-boundaries for definition of text objects"
  331.   (interactive "d")
  332.   (let ((bounds (thing-boundaries here)))
  333.     (copy-region-as-kill (car bounds) (cdr bounds))))
  334.